home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / View-Extensions.lisp < prev   
Encoding:
Text File  |  1992-09-02  |  23.2 KB  |  679 lines  |  [TEXT/CCL2]
  1. ;;; View-Extensions.lisp
  2. ;;;
  3. ;;; This is a collection of classes and methods that extend the functionality of
  4. ;;; views in MCL 2.0.  Some of the most useful extensions are the definition of 
  5. ;;; relative position views which hopefully future versions of MCL will include,
  6. ;;; editable-number-dialog-item, and drag-view method.
  7. ;;; 
  8. ;;; Address: Gordon Sawatzky
  9. ;;;          National Research Council Canada
  10. ;;;          435 Ellice Avenue
  11. ;;;          Winnipeg, MB R3B 1Y6
  12. ;;;
  13. ;;; This code is in the public domain and is distributed without warranty
  14. ;;; of any kind. 
  15. ;;;
  16. ;;; Bug reports, comments, and suggestions should be sent to sawatzky@ciitip.ciit.ca
  17. ;;; 
  18. ;;;
  19. ;;; 
  20. ;;; The following is a brief description of all classes and methods contained in
  21. ;;; this file:
  22. ;;; 
  23. ;;;
  24. ;;; 
  25.  
  26. ;;;   o Simple view position methods to make code more readable
  27.  
  28. ;;; (view-width (simple-view))
  29. ;;; (view-height (simple-view))
  30. ;;; (view-right (simple-view))
  31. ;;; (view-left (simple-view))
  32. ;;; (view-bottom (simple-view))
  33. ;;; (view-top (simple-view))
  34. ;;; (middle-left (simple-view))
  35. ;;; (middle-right (simple-view))
  36. ;;; (middle-top (simple-view))
  37. ;;; (middle-bottom (simple-view))
  38. ;;; (bottom-left (simple-view))
  39. ;;; (bottom-right (simple-view))
  40. ;;; (top-right (simple-view))
  41. ;;; (top-left (simple-view))
  42.  
  43. ;;;   o Simple point predicates for views
  44.  
  45. ;;; (point-in-right-side-p (simple-view t))
  46. ;;; (point-in-left-side-p (simple-view t))
  47. ;;; (point-in-bottomright-p (simple-view t))
  48. ;;; (View-In-Rect (simple-view t))
  49. ;;; (View-partly-In-Rect (simple-view t))
  50.  
  51.  
  52. ;;;   o Simple graphic methods for views to make code more readable
  53.  
  54. ;;; (view-erase (simple-view))
  55. ;;; (view-frame (simple-view))
  56. ;;; (view-draw-vertical-line (simple-view t))
  57. ;;; (view-draw-horizontal-line (simple-view t))
  58. ;;; (view-invert (simple-view))
  59. ;;; (view-draw-corner-handles (simple-view))
  60. ;;; (view-draw-top-left-handle (simple-view))
  61. ;;; (view-draw-top-right-handle (simple-view))
  62. ;;; (view-draw-bottom-left-handle (simple-view))
  63. ;;; (view-draw-bottom-right-handle (simple-view))
  64. ;;; (view-draw-top-handle (simple-view))
  65. ;;; (view-draw-right-handle (simple-view))
  66. ;;; (view-draw-left-handle (simple-view))
  67. ;;; (view-draw-bottom-handle (simple-view))
  68.  
  69.  
  70.  
  71. ;;;   o Center view method, Relative views, drag-view-size and drag-view-position
  72.  
  73. ;;; (center-view (simple-view))
  74. ;;; centered-text
  75. ;;; relative-view
  76. ;;; (object-source-code (dialog-item))
  77. ;;; relative-button
  78. ;;; relative-table
  79. ;;; (drag-view-position (simple-view view))
  80. ;;; (drag-view-size (simple-view view))
  81. ;;; (drag-rect (view))
  82.  
  83. ;;;   o Other views
  84.  
  85. ;;; editable-number-dialog-item
  86. ;;; (dialog-item-number (editable-number-dialog-item))
  87. ;;; axis-view
  88. ;;; movable-dialog-item
  89.  
  90.  
  91.  
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93.  
  94.  
  95. (require 'QuickDraw)
  96.  
  97.  
  98.  
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100.  
  101. ;;; Some interesting points of views
  102.  
  103. (defmethod view-width ((view simple-view))
  104.   (point-h (view-size view)))
  105.  
  106. (defmethod view-height ((view simple-view))
  107.   (point-v (view-size view)))
  108.  
  109.  
  110.  
  111. (defmethod view-right ((view simple-view))
  112.   (+ (point-h (view-position view))
  113.      (point-h (view-size view))))
  114.  
  115. (defmethod view-left ((view simple-view))
  116.   (point-h (view-position view)))
  117.  
  118.  
  119. (defmethod view-bottom ((view simple-view))
  120.   (+ (point-v (view-position view))
  121.      (point-v (view-size view))))
  122.  
  123. (defmethod view-top ((view simple-view))
  124.   (point-v (view-position view)))
  125.  
  126.  
  127. (defmethod middle-left ((self simple-view))
  128.   (let ((dp (view-position self)) (s (view-size self)))
  129.     (make-point (point-h dp) 
  130.                 (+ (point-v dp) (round (point-v s) 2)))))
  131.  
  132.  
  133. (defmethod middle-right ((self simple-view))
  134.   (let ((dp (view-position self)) (s (view-size self)))
  135.     (make-point (+ (point-h dp) (point-h s))
  136.                 (+ (point-v dp) (round (point-v s) 2))))) 
  137.  
  138.  
  139. (defmethod middle-top ((self simple-view))
  140.   (let ((dp (view-position self)) (s (view-size self)))
  141.     (make-point (+ (point-h dp) (round (point-h s) 2)) 
  142.                 (point-v dp))))
  143.  
  144.  
  145. (defmethod middle-bottom ((self simple-view))
  146.   (let ((dp (view-position self)) (s (view-size self)))
  147.     (make-point (+ (point-h dp) (round (point-h s) 2))
  148.                 (+ (point-v dp) (point-v s))))) 
  149.  
  150.  
  151. (defmethod bottom-left ((self simple-view))
  152.   (let ((dp (view-position self)) (s (view-size self)))
  153.     (make-point (point-h dp) (+ (point-v dp) (point-v s)))))
  154.  
  155.  
  156. (defmethod bottom-right ((self simple-view))
  157.   (let ((dp (view-position self)) (s (view-size self)))
  158.     (make-point (+ (point-h dp) (point-h s))
  159.                 (+ (point-v dp) (point-v s)))))
  160.  
  161. (defmethod top-right ((self simple-view))
  162.   (let ((dp (view-position self)) (s (view-size self)))
  163.     (make-point (+ (point-h dp) (point-h s))
  164.                 (+ (point-v dp)))))
  165.  
  166. (defmethod top-left ((self simple-view))
  167.   (view-position self))
  168.  
  169.  
  170. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  171. ;;;
  172. ;;;   View position predicates
  173.  
  174.  
  175. (defmethod point-in-right-side-p ((self simple-view) p)
  176.   (let ((dp (view-position self))
  177.         (s (view-size self)))
  178.     (rlet ((r :rect :left (+ (point-h dp) (round (point-h s) 2))
  179.               :top (point-v dp)
  180.               :right (+ (point-h dp) (point-h s))
  181.               :bottom (+ (point-v dp) (point-v s))))
  182.       (point-in-rect-p r p))))
  183.  
  184. (defmethod point-in-left-side-p ((self simple-view) p)
  185.   (let ((dp (view-position self))
  186.         (s (view-size self)))
  187.     (rlet ((r :rect :left (point-h dp) 
  188.               :top (point-v dp)
  189.               :right (+ (point-h dp) (round (point-h s) 2))
  190.               :bottom (+ (point-v dp) (point-v s))))
  191.       (point-in-rect-p r p))))
  192.           
  193.  
  194.  
  195. (defmethod point-in-bottomright-p ((self simple-view) p &optional (offset #@(10 10)))
  196.   "Returns t if p of container is in bottomright of this view"
  197.   (point-in-rect-p (make-record :rect 
  198.                                 :topleft (subtract-points 
  199.                                           (view-size self)
  200.                                           offset)
  201.                                 :bottomright (view-size self))
  202.                    (subtract-points p (view-position self))))
  203.  
  204. (defmethod View-In-Rect ((self simple-view) rect)
  205.   (and (point-in-rect-p rect (view-position self))
  206.        (point-in-rect-p rect (add-points (view-position self)
  207.                                          (view-size self)))))
  208.  
  209. (defmethod View-partly-In-Rect ((self simple-view) rect)
  210.   (or (point-in-rect-p rect (view-position self))
  211.       (point-in-rect-p rect (top-right self))
  212.       (point-in-rect-p rect (bottom-right self))
  213.       (point-in-rect-p rect (bottom-left self))))
  214.  
  215. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  216. ;;; 
  217. ;;; some simple graphic methods
  218. ;;; 
  219.  
  220. (defmethod view-erase ((view simple-view))
  221.   (ccl::erase-rect view #@(0 0)  (view-size view)))
  222.  
  223. (defmethod view-frame ((view simple-view))
  224.   (ccl::frame-rect view #@(0 0)  (view-size view)))
  225.  
  226. (defmethod view-draw-vertical-line ((view simple-view) h)
  227.   (ccl::move-to view (make-point h 0))
  228.   (ccl::line-to view (make-point h (view-height view))
  229.   ))
  230.  
  231. (defmethod view-draw-horizontal-line ((view simple-view) v)
  232.   (ccl::move-to view (make-point 0 v))
  233.   (ccl::line-to view (make-point (view-width view) v)
  234.   ))
  235.  
  236. (defmethod view-invert ((self simple-view))
  237.   (ccl::invert-rect self #@(0 0) (view-size self)))
  238.  
  239. (defvar *handle-size* 4)
  240.  
  241. (defmethod view-draw-corner-handles ((self simple-view))
  242.   (view-draw-top-left-handle self)
  243.   (view-draw-top-right-handle self) 
  244.   (view-draw-bottom-left-handle self)
  245.   (view-draw-bottom-right-handle self))
  246.  
  247. (defmethod view-draw-top-left-handle ((self simple-view))
  248.   (ccl::paint-rect self #@(0 0) (make-point *handle-size* *handle-size*)))
  249.  
  250. (defmethod view-draw-top-right-handle ((self simple-view))
  251.   (let ((r (point-h (view-size self))))
  252.     (ccl::paint-rect self (make-point (- r *handle-size*) 0) 
  253.                      (make-point r *handle-size*))))
  254.  
  255. (defmethod view-draw-bottom-left-handle ((self simple-view))
  256.   (let ((h (point-v (view-size self))))
  257.     (ccl::paint-rect self (make-point 0 (- h *handle-size*))
  258.                      (make-point *handle-size* h))))
  259.  
  260. (defmethod view-draw-bottom-right-handle ((self simple-view))
  261.   (let ((r (point-h (view-size self)))
  262.         (h (point-v (view-size self))))
  263.     (ccl::paint-rect self (make-point (- r *handle-size*) (- h *handle-size*)) 
  264.                      (make-point r h))))
  265.  
  266.  
  267. (defmethod view-draw-top-handle ((self simple-view))
  268.   (let ((r (point-h (view-size self))))
  269.     (ccl::paint-rect self (make-point 0 0) 
  270.                      (make-point r *handle-size*))))
  271.  
  272. (defmethod view-draw-right-handle ((self simple-view))
  273.   (let ((r (point-h (view-size self)))
  274.         (h (point-v (view-size self))))
  275.     (ccl::paint-rect self (make-point (- r *handle-size*) 0) 
  276.                      (make-point r h))))
  277.  
  278. (defmethod view-draw-left-handle ((self simple-view))
  279.   (let ((h (point-v (view-size self))))
  280.     (ccl::paint-rect self (make-point 0 0)
  281.                      (make-point *handle-size* h))))
  282.  
  283. (defmethod view-draw-bottom-handle ((self simple-view))
  284.   (let ((r (point-h (view-size self)))
  285.         (h (point-v (view-size self))))
  286.     (ccl::paint-rect self (make-point 0 (- h *handle-size*)) 
  287.                      (make-point r h))))
  288.  
  289.  
  290.  
  291.            
  292. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  293.  
  294. (defmethod center-view ((self simple-view))
  295.   (when (view-container self)
  296.     (cond ((> (view-width self) (view-width (view-container self)))
  297.            (ed-beep) nil)
  298.           (t 
  299.            (set-view-position self
  300.                               (make-point (floor (- (view-width (view-container self))
  301.                                                     (view-width self))
  302.                                                  2)
  303.                                           (point-v (view-position self))))
  304.            (invalidate-view self)
  305.            (view-draw-contents self)))))
  306.  
  307. (defclass centered-text (static-text-dialog-item)
  308.   ())
  309.  
  310. (defmethod set-dialog-item-text :before ((self centered-text) text)
  311.   (set-view-size self (make-point (+  (string-width text (view-font self)) 10)
  312.                                   (view-height self)))
  313.   (center-view self))
  314.  
  315.  
  316.  
  317. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  318.  
  319. (defclass relative-view (simple-view) 
  320.   ((rel-position :initarg :rel-position :accessor rel-position :initform nil)
  321.    (rel-size :initarg :rel-size :accessor rel-size :initform nil)))
  322.  
  323.  
  324. (defmethod set-view-container :before ((self relative-view) new-container)
  325.   (when new-container
  326.     (set-relative-view-size self new-container)))
  327.  
  328. (defmethod set-relative-view-size ((self relative-view) container)
  329.   (let ((current-position (if (view-position self) 
  330.                             (view-position self) #@(0 0)))
  331.         (current-size (if (view-size self) 
  332.                         (view-size self) #@(30 12)))
  333.         (container-width (view-width container))
  334.         (container-height (view-height container)))
  335.     
  336.     (case (car (rel-position self))
  337.       (nil nil)
  338.       (:right (set-view-position self (- container-width
  339.                                          (cadr (rel-position self))
  340.                                          (point-h current-size))
  341.                                  (point-v current-position)))
  342.       (:left (set-view-position self (cadr (rel-position self))
  343.                                 (point-v current-position)))
  344.       (:top (set-view-position self (point-h current-position) 
  345.                                (cadr (rel-position self))))
  346.       (:bottom (set-view-position self (point-h current-position)
  347.                                   (- container-height
  348.                                      (cadr (rel-position self))
  349.                                      (point-v current-size)))))
  350.     (case (car (rel-size self))
  351.       (nil nil)
  352.       (:width (set-view-size self (- container-width
  353.                                      (cadr (rel-size self)))
  354.                              (point-v current-size)))
  355.       (:height (set-view-size self (point-h current-size)
  356.                               (- container-height 
  357.                                  (cadr (rel-size self)))))
  358.       (:bottom-right-offset (set-view-size self 
  359.                               (subtract-points
  360.                                (subtract-points (view-size container)
  361.                                                 (cadr (rel-size self)))
  362.                                current-position)))
  363.       (:%width (set-view-size self (round (* container-width 
  364.                                              (cadr (rel-size self))))
  365.                               (point-v current-size)))
  366.       (:%height (set-view-size self (point-h current-size)
  367.                                (round (* container-height 
  368.                                          (cadr (rel-size self))))))))
  369. ;  (if (view-container self) (view-draw-contents self))
  370.   )
  371.  
  372. (defmethod set-view-size :after ((self view) h &optional v)
  373.   (declare (ignore h v))
  374.   (dolist (v (subviews self 'relative-view))
  375.     (set-relative-view-size v self)))
  376.  
  377.  
  378.  
  379. #| Change to IFT item-defs.lisp file to handle relative-views
  380.  
  381. (defmethod object-source-code ((item dialog-item) &aux my-font)
  382.   `(make-dialog-item  ',(class-name (class-of item))
  383.                       ,(ppoint (view-position item))
  384.                       ,(ppoint (view-size item))
  385.                       ,(dialog-item-text item)
  386.                       ,(let* ((f (dialog-item-action-function item))
  387.                               (code (and (functionp f) (uncompile-function f))))
  388.                          (cond ((symbolp f) `,f)
  389.                                (code `#',code)
  390.                                (t nil)))
  391.                       ,@(let ((nick-name (view-nick-name item)))
  392.                           (and nick-name
  393.                                `(:view-nick-name ',nick-name)))
  394.                       ,@(cond ((typep item 'cl-user::relative-view)
  395.                                `(:rel-position ',(cl-user::rel-position item)
  396.                                  :rel-size ',(cl-user::rel-size item)))
  397.                               (t nil))
  398.                       ,@(if (dialog-item-enabled-p item)
  399.                           ()
  400.                           '(:dialog-item-enabled-p nil))
  401.                       ,@(if (equal (setq my-font (view-font item))
  402.                                    (window-font (view-window item)))
  403.                           ()
  404.                           `(:view-font ',my-font))
  405.                       ,@(let ((color-list (part-color-list item)))
  406.                           (and color-list
  407.                                `(:part-color-list ',color-list)))))
  408.  
  409. |#
  410.  
  411.  
  412.  
  413. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  414. ;;;
  415. ;;;  Some relative dialog items
  416. ;;;
  417. (defclass relative-button (button-dialog-item relative-view) 
  418.   ()
  419.   (:documentation "A button whose position can be raltive to the container"))
  420.  
  421. (defclass relative-table (sequence-dialog-item relative-view) 
  422.   ()
  423.   (:documentation "A table whose position can be raltive to the container"))
  424.  
  425. (defmethod set-relative-view-size :after ((self relative-table) container)
  426.   (declare (ignore container))
  427.   (set-cell-size self (- (view-width self) 15) 
  428.                  (point-v (cell-size self))
  429.                  ))
  430.  
  431.  
  432. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  433. ;;;
  434. ;;;  Movable views
  435.  
  436.  
  437.  
  438. (defmethod drag-view-position ((self simple-view) (container view) &optional other-views)
  439.   (ccl::set-pen-mode container :patxor)
  440.   (ccl::set-pen-pattern self *gray-pattern*)
  441.   (let* ((size (view-size self))
  442.          (view-pos (view-position self))
  443.          (p1 (view-mouse-position container))
  444.          (p2 p1)
  445.          (delta #@(0 0))
  446.          )
  447.     (loop
  448.       (setf p2 (view-mouse-position container))
  449.       (cond ((mouse-down-p)
  450.              (unless (= p1 p2)
  451.                (frame-rect container (add-points view-pos delta) 
  452.                            (add-points (add-points view-pos delta) size))
  453.                (setf delta (add-points delta (subtract-points p2 p1)))
  454.                (setf p1 p2)
  455.                (frame-rect container (add-points view-pos delta) 
  456.                            (add-points (add-points view-pos delta) size)))
  457.              )
  458.             (t (return t)))
  459.       )
  460.     (ccl::set-pen-pattern self *black-pattern*)
  461.     (ccl::set-pen-mode container :patCopy)
  462.     (unless (= delta #@(0 0))
  463.       (set-view-position self (add-points view-pos delta))
  464.       (dolist (v other-views)
  465.         (set-view-position v (add-points (view-position v) delta)))))
  466.   )
  467.  
  468.  
  469. (defmethod drag-view-size ((self simple-view) (container view))
  470.   
  471.   (let ((new-rect (drag-rect container (view-position self)
  472.                              (bottom-right self))))
  473.     (cond ((empty-rect-p new-rect) nil)
  474.           (t
  475.            (if (= (view-position self) (rref new-rect :rect.topleft))
  476.              nil (set-view-position self (rref new-rect :rect.topleft)))
  477.            (set-view-size self (subtract-points (rref new-rect :rect.bottomright)
  478.                                                 (rref new-rect :rect.topleft)))
  479.            ))
  480.     (dispose-record new-rect))
  481.   (view-draw-contents self))
  482.  
  483.  
  484.  
  485.  
  486. (defmethod drag-rect ((self view) &optional (start (view-mouse-position self))
  487.                       (pos (view-mouse-position self)))
  488.   (ccl::set-pen-mode self :patxor)
  489.   (ccl::set-pen-pattern self *gray-pattern*)
  490.   (let ((rect (make-record :rect))
  491.          p1 p2)
  492.     (setf p1 (view-mouse-position self))
  493.     (setf p2 p1)
  494.     (loop
  495.       (setf p2 (view-mouse-position self))
  496.       (cond ((mouse-down-p)
  497.              (unless (= p1 p2)
  498.                (points-to-rect start pos rect)
  499.                (frame-rect self rect)
  500.                (setf pos (add-points pos (subtract-points p2 p1)))
  501.                (setf p1 p2)
  502.                (points-to-rect start pos rect)
  503.                (frame-rect self rect))
  504.              )
  505.             (t (points-to-rect start pos rect)
  506.                (frame-rect self rect)
  507.                (return t)))
  508.       )
  509.     
  510.     (ccl::set-pen-mode self :patCopy)
  511.     (ccl::set-pen-pattern self *black-pattern*)
  512.     (points-to-rect start pos rect)))
  513.  
  514.  
  515. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  516. ;;; 
  517. ;;; Other dialog-items and views
  518.  
  519.  
  520. (defclass editable-number-dialog-item (editable-text-dialog-item)
  521.   ((integer :initarg :integer :accessor integer :initform nil)
  522.    (lower-bound :initarg :lower-bound :accessor lower-bound :initform nil)
  523.    (upper-bound :initarg :upper-bound :accessor upper-bound :initform nil))
  524.   (:documentation "Allows user to enter numbers (within a range) only"))
  525.  
  526.  
  527. (defmethod dialog-item-number ((self editable-number-dialog-item))
  528.   (read-from-string (dialog-item-text self)))
  529.  
  530. (defmethod exit-key-handler ((self editable-number-dialog-item)
  531.                                new-text-item)
  532.   (declare (ignore new-text-item))
  533.   (let ((integer (integer self))
  534.         (lower-bound (lower-bound self))
  535.         (upper-bound (upper-bound self))
  536.         (thing (read-from-string (dialog-item-text self) nil nil))
  537.         (message-position (local-to-global (view-window self)
  538.                                            (add-points #@(5 10)
  539.                                                        (bottom-left self)))))
  540.     (cond ((not (numberp thing)) 
  541.            (message-dialog "This field must be a number !!"
  542.                            :size #@(150 80)
  543.                            :position  message-position
  544.                            )
  545.            nil)
  546.           ((and lower-bound (< thing lower-bound))
  547.            (message-dialog 
  548.             (format nil "This number must be >= ~D " lower-bound)
  549.             :size #@(300 100)
  550.             :position 
  551.             message-position)
  552.            nil)
  553.           ((and upper-bound (> thing upper-bound))
  554.            (message-dialog 
  555.             (format nil "This number must be <= ~D " upper-bound)
  556.             :size #@(300 100)
  557.             :position 
  558.             message-position)
  559.            nil)
  560.           ((and integer (not (integerp thing)))
  561.            (set-dialog-item-text self (format nil "~D" (floor thing)))
  562.            t)
  563.           (t t))))
  564.  
  565.  
  566.  
  567. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  568.  
  569.  
  570. (defclass axis-view (simple-view)
  571.   ((orientation :initarg :orientation :accessor orientation :initform :vertical)
  572.    (axis-length :initarg :axis-length :accessor axis-length :initform 100)
  573.    (tick-length :initarg :tick-length :accessor tick-length :initform 5)
  574.    (tick-spacing :initarg :tick-spacing :accessor tick-spacing :initform 10)
  575.    ))
  576.  
  577. (defmethod initialize-instance :after ((self axis-view) &rest initargs)
  578.        (declare (ignore initargs))
  579.        (if (equal (orientation self) :vertical)
  580.          (set-view-size self (make-point (tick-length self) (1+ (axis-length self))))
  581.          (set-view-size self (make-point (1+ (axis-length self)) (tick-length self)))))
  582.            
  583. (defmethod view-draw-contents ((self axis-view) &aux (x 0) l)
  584.   (cond ((equal (orientation self) :vertical)
  585.          (view-draw-vertical-line self (round (view-width self) 2))
  586.          (setf l (+ (view-height self) 1))
  587.          (loop
  588.            (view-draw-horizontal-line self x)
  589.            (incf x (tick-spacing self))
  590.            (if (>= x l) (return nil))))
  591.         (t
  592.          (view-draw-horizontal-line self (round (view-height self) 2))
  593.          (setf l (+ (view-width self) 1))
  594.          (loop
  595.            (view-draw-vertical-line self x)
  596.            (incf x (tick-spacing self))
  597.            (if (>= x l) (return nil))))))
  598.  
  599.  
  600.  
  601.  
  602. (provide 'View-Extensions)
  603.  
  604. #| Testing Stuff
  605.  
  606.  
  607. (setf w1 (make-instance 'window
  608.                 :view-position (make-point 520 100)))
  609.  
  610.  
  611. (make-instance 'axis-view
  612.                :view-position #@(10 10)
  613.                :orientation :horizontal
  614.                :view-container w1)
  615.  
  616. (defclass foo (relative-view) ())
  617.  
  618. (defmethod view-draw-contents ((self foo))
  619.   (view-erase self)
  620.   (view-frame self)
  621.   (move-to self #@(5 10))
  622.   (princ "Relative View - Change Window Size" self))
  623.  
  624. (make-instance 'foo 
  625.                 :view-container w1
  626.                 :view-position (make-point 10 60)
  627. ;                :rel-position '(:bottom 40)
  628. ;                :rel-size '(:bottom 50)
  629.                 :rel-size '(:bottom-right-offset #@(100 50))
  630.                 :view-font '("Geneva" 9 :Plain)
  631.                 )
  632.  
  633. (make-instance 'relative-button
  634.                :dialog-item-text "BEEP"
  635.                :dialog-item-action 'ed-beep
  636.                :view-position #@(20 40)
  637.                :rel-position '(:right 20)
  638.                :view-container w1
  639.                )
  640.  
  641.  
  642. (make-instance 'editable-number-dialog-item
  643.                :view-size #@(40 18)
  644.                :view-container w1
  645.                :dialog-item-text "0"
  646.                :lower-bound 0
  647.                :upper-bound 10
  648.                :integer t
  649.                )
  650.  
  651. (make-instance 'editable-number-dialog-item
  652.                :view-size #@(40 18)
  653.                :view-container w1
  654.                :dialog-item-text "0"
  655.                :lower-bound 0
  656.                :integer t
  657.                )
  658.  
  659. (defclass movable-dialog-item (dialog-item) ())
  660.  
  661. (defmethod view-click-event-handler ((self movable-dialog-item) p)
  662.   (if (point-in-bottomright-p self p)
  663.     (drag-view-size self (view-container self))
  664.     (drag-view-position self (view-container self))))
  665.  
  666. (defmethod view-draw-contents ((self movable-dialog-item))
  667.   (view-erase self)
  668.   (view-frame self)
  669.   (move-to self #@(5 10))
  670.   (princ "Click and Drag" self)
  671.   (view-draw-bottom-right-handle self))
  672.  
  673. (make-instance 'movable-dialog-item
  674.                :view-size #@(40 20)
  675.                :view-container w1
  676.                :view-font '("Geneva" 9 :Plain))
  677.  
  678. |#
  679.